home *** CD-ROM | disk | FTP | other *** search
- /****************************************************************************
- * *
- * $VER: Links 1.18 (31 Oct 1995)
- * *
- * Written by Freddy Ariës *
- * Address: Lindeboomweg 7, NL-7135 KE Harreveld, The Netherlands. *
- * *
- * ARexx script to find unrelated family trees in the database *
- * It will detect all family trees within the database that have no links *
- * (spouse, parent or child links) to other present family trees. *
- * Eg. useful to find out if you forgot to add a link somewhere... *
- * *
- * This script uses (by default) the rexxreqtools.library (which requires *
- * a version of reqtools larger than 2.0 and rexxsyslib.library) *
- * If you do not have these, run SetDefaults.rexx to change the settings. *
- * *
- * DONE: *
- * - progress indicator, using rexxarplib.library (requested by R.Akins) *
- * - now uses preference file for default settings *
- * *
- ****************************************************************************/
-
- options results
- arg outname outval
-
- versionstr = "1.18"
-
- /* Don't change the settings here! Run SetDefaults.rexx instead! */
- usereq = 1; prgrs = 1; pgopen = 0
- outp = 1; output = stdout; scrdev = stdout
- PSCR = 'SCIONGEN'
- plwidth = 78; pgsize = 0
-
- fill = 4; /* number of spaces at the beginning of lines */
- useirn = 1; pgline = 1
- scrname = "CON:0//639//Scion Output/AUTO/SCREEN"
- NL = '0A'x
-
- signal on IOERR
-
- do while outname = '?'
- writeln(stdout, "OUTFILE/A,QUIET/S,NOREQ/S ")
- pull outname outval
- end
-
- /* read preferences file */
-
- if open(pfile, 'ENV:Scion/ScionRexx.prefs', 'r') then do
- do while ~eof(pfile)
- inln = readln(pfile)
- if inln ~= "" then do
- wstr = upper(word(inln, 1))
- if wstr = "USEREQ" then
- usereq = 1
- else if wstr = "NOUSEREQ" then
- usereq = 0
- else if wstr = "PROGRESS" then
- prgrs = 1
- else if wstr = "NOPROGRESS" then
- prgrs = 0
- else if wstr = "PUBSCREEN" then
- pscr = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
- else if wstr = "LINEWIDTH" then do
- wstr = word(inln, 2)
- if datatype(wstr, 'w') then plwidth = wstr
- end
- else if wstr = "PAGESIZE" then do
- wstr = word(inln, 2)
- if datatype(wstr, 'w') then pgsize = wstr
- end
- end
- end
- close(pfile)
- end
-
- if pscr = "" | (pscr ~= "WORKBENCH" & ~show('p', pscr)) then
- pscr = "SCIONGEN"
- scrname = scrname||pscr
-
- /* command line options get priority over global settings */
-
- if outname ~= "" then do
- if outname = "QUIET" | outname = "NOREQ" then do
- outval = outname; outname = ""
- end
- end
-
- if outval = "QUIET" then do
- outp = 0; usereq = 0; prgrs = 0
- end
- else if outval = "NOREQ" then do
- usereq = 0; prgrs = 0
- end
-
- if usereq & ~show('l','rexxreqtools.library') then do
- if exists('libs:rexxreqtools.library') then
- call addlib('rexxreqtools.library',0,-30,0)
- else do
- usereq = 0; outp = 1
- Tell("Unable to open rexxreqtools.library - using text output")
- end
- end
-
- if ~usereq then prgrs = 0
-
- /* Originally stolen from Peter Billing - thanks Peter ;-) */
- if ~show('P','SCIONGEN') then do
- EndString('I am sorry to say that the SCION Genealogist' || NL ||,
- 'database is not available. Please start the' || NL ||,
- 'SCION program BEFORE using this script!')
- end
-
- if prgrs & ~show('l','rexxarplib.library') then do
- if exists('libs:rexxarplib.library') then
- call addlib('rexxarplib.library',0,-30,0)
- else
- prgrs = 0
- end
-
- screentofront(pscr)
-
- myport = "SCIONGEN"
- address value myport
- GETDBNAME
- dbname = upper(RESULT)
-
- Arrays. = ""
- CurrIRN = 1; arr = 1; Arrays.1 = "1 "
- NumArrs = 1; Found = 1
-
- if outp & ~usereq then do
- if pscr ~= "WORKBENCH" then do
- scrdev = 'SCNLNKSCR'
- if ~open(scrdev, scrname, 'w') then scrdev = stdout
- end
- Tell("Scion Links Finder v"||versionstr||" by Freddy Ariës")
- Tell("Current Scion database: "||dbname)
- Tell("Be patient - this may take a while...")
- end
-
- /* It's a good habit to add the ".scion" extension to Scion database files */
- dblen = length(dbname)
- if dblen>6 & right(dbname, 6)=".SCION" then dbname=left(dbname, dblen - 6)
-
- if outname = "" then do
- if outp then do
- if usereq then do
- odev = rtezrequest('Current Scion database: '||dbname||,
- NL||'Where should the Links output be sent to?'||,
- NL,' _File |_Printer|_Screen|_Nowhere','Scion Links Finder v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
- select
- when odev = 1 then do
- /* We need a file requester for further data */
- outname = rtfilerequest(,dbname||'.LNK','Output filename',,'rtfi_buffer = true rt_pubscrname = '||PSCR||' rtfi_initialpath = RAM:',)
- if outname = '' then
- outname = dbname||'.LNK'
- end
- when odev = 2 then
- outname = 'PRT:'
- when odev = 3 then
- outname = 'STDOUT'
- otherwise
- EXIT
- /* You selected 'Nowhere' */
- end
- end
- else do
- Tell("Enter output file (filename with complete path, or PRT: for printer,")
- TellNN("or STDOUT for screen): ")
- outname = readln(scrdev)
- outname = strip(outname, 'b', ' "')
- Tell("Destination: "||outname)
- TellNN("Continue (y/n)? ")
- conf = readln(scrdev)
- conf = upper(left(conf, 1))
- /* Note that left works on empty strings ("") too! */
- if conf ~= "Y" then
- EndString("Goodbye...")
- Tell("")
- end
- end
- else
- outname = "RAM:"dbname".LNK"
- /* If we're not allowed to use stdout, default to this filename */
- end
-
- if prgrs then do
- Postmsg(10, 10, "Scion Links Finder (by Freddy Ariës)\Database: "||dbname||"\ \ ", PSCR)
- pgopen = 1
- end
-
- GETTOTALIRN
- TotalIRN = RESULT
- if pgopen then Postmsg(,, "\\Processing person:\", PSCR)
-
- do while CurrIRN <= TotalIRN
- if pgopen then Postmsg(,,"\\\"||CurrIRN||" (of "||TotalIRN||")", PSCR)
- if Found then do
- MarrNum = 0; marrexist = 1
-
- do while marrexist
- GETMARRIAGE CurrIRN MarrNum
- marriage = RESULT
- EXISTFAMILY marriage
- if RESULT = 'YES' then do
- marrexist = 1
-
- PrsnIRN = 0
- GETPRINCIPAL marriage
- ptnr = RESULT
- EXISTPERSON ptnr
- if RESULT = 'YES' then do
- if ptnr ~= CurrIRN then PrsnIRN = ptnr
- end
- if PrsnIRN = 0 then do
- GETSPOUSE marriage
- ptnr = RESULT
- EXISTPERSON ptnr
- if RESULT = 'YES' then do
- if ptnr ~= CurrIRN then PrsnIRN = ptnr
- end
- end
-
- EXISTPERSON PrsnIRN
- if RESULT = 'YES' then
- arr = HandlePerson(PrsnIRN)
-
- ChildNum = 0; childexist = 1
- do while childexist
- GETCHILD marriage ChildNum
- child = RESULT
- EXISTPERSON child
- if RESULT = 'YES' then do
- childexist = 1
- arr = HandlePerson(child)
- ChildNum = ChildNum + 1
- end
- else childexist = 0
- end
-
- MarrNum = MarrNum + 1
- end
- else marrexist = 0
- end
-
- GETPARENTS CurrIRN
- ParFGRN = RESULT
- EXISTFAMILY ParFGRN
- if RESULT = 'YES' then do
- GETPRINCIPAL ParFGRN
- PrsnIRN = RESULT
- EXISTPERSON PrsnIRN
- if RESULT = 'YES' then do
- arr = HandlePerson(PrsnIRN)
- end
-
- GETSPOUSE ParFGRN
- PrsnIRN = RESULT
- EXISTPERSON PrsnIRN
- if RESULT = 'YES' then
- arr = HandlePerson(PrsnIRN)
-
- /* Note that we don't have to process siblings, because they will
- * be processed with their parents, and because you cannot create
- * a family group without at least one parent
- */
- end
- end
-
- CurrIRN = CurrIRN + 1
- EXISTPERSON CurrIRN
-
- if RESULT = 'YES' then do
- arr = GetArray(CurrIRN)
- Found = 1
- end
- else Found = 0
- end
-
- if pgopen then Postmsg(,, "\\Writing output...\ ", PSCR)
-
- if outname ~= "STDOUT" then do
- output = 'OUTPUT'
- if ~open(output, outname, "w") then
- EndString("ERROR: Unable to open output file.")
- end
- else
- output = scrdev
-
- /* Now output the resulting arrays of IRNs! */
- do out = 1 for NumArrs
- PrintLines("Group "||out||": "||Arrays.out, fill)
- end
-
- if usereq then do
- rtezrequest('Scion Links Finder is ready.' || NL ||'Persons parsed: '||,
- TotalIRN,'_Ok','Links Message:','rt_pubscrname = '||PSCR)
- if pgopen then Postmsg()
- end
- else
- EndString("Done ("||TotalIRN||" persons parsed)."||NL)
-
- EXIT
-
- GetArray: PROCEDURE EXPOSE Arrays. NumArrs
- parse arg prsn
- do CurrArr = 1 for NumArrs
- col = find(Arrays.CurrArr, prsn)
- if col > 0 then return CurrArr
- end
- /* Not already present, then give person a new array */
- NumArrs = NumArrs + 1
- Arrays.NumArrs = prsn||' '
- return NumArrs
-
- MergeArrs: PROCEDURE EXPOSE Arrays. NumArrs
- parse arg arr1, arr2
- if arr1 <= arr2 then do
- minarr = arr1; maxarr = arr2
- end
- else do
- minarr = arr2; maxarr = arr1
- end
- Arrays.minarr = Arrays.minarr||Arrays.maxarr
- if maxarr ~= NumArrs then
- Arrays.maxarr = Arrays.NumArrs
- Arrays.NumArrs = ""
- NumArrs = NumArrs - 1
- return minarr
-
- HandlePerson: PROCEDURE EXPOSE Arrays. NumArrs arr
- parse arg prsn
- CurrArr = 1; pers = 0
- do until pers ~= 0 | CurrArr > NumArrs
- if find(Arrays.CurrArr, prsn) > 0 then pers = CurrArr
- CurrArr = CurrArr + 1
- end
- if pers = 0 then do
- /* Person isn't already present; give him same array as CurrIRN person */
- pers = arr
- Arrays.arr = Arrays.arr||prsn||' '
- end
- if pers ~= arr then
- arr = MergeArrs(pers, arr)
- return arr
-
- PrintLines: PROCEDURE EXPOSE output plwidth pgline pgsize
- parse arg ostr, fill
- do while ostr ~= ""
- nnl = plwidth
- if length(ostr) >= plwidth then do
- do until pc = ' ' | nnl = 1
- pc = substr(ostr, nnl, 1)
- nnl = nnl - 1
- end
- if nnl = 1 then do
- prtstr = left(ostr, plwidth-1)
- ostr = delstr(ostr, 1, nnl)
- end
- else do
- prtstr = left(ostr, nnl)
- ostr = delstr(ostr, 1, nnl+1)
- end
- end
- else do
- prtstr = ostr
- ostr = ""
- end
- DoWrite(output, prtstr)
- if ostr ~= "" then
- ostr = copies(' ',fill)||ostr
- end
- return 0
-
- /*
- * output at most #pgsize lines per page to the print device
- * if pgsize = 0, this feature is turned off (unlimited #lines per page)
- */
- DoWrite: PROCEDURE EXPOSE pgline pgsize
- parse arg prtdev, ostr
- if pgsize ~= 0 & pgline > pgsize then do
- writech(prtdev, '0C'x); /* CTRL-L; next page */
- pgline = 0
- end
- writeln(prtdev, ostr)
- pgline = pgline + 1
- return 0
-
- Tell: PROCEDURE EXPOSE outp scrdev
- parse arg str
- if outp then writeln(scrdev, str)
- return 0
-
- TellNN: PROCEDURE EXPOSE outp scrdev
- parse arg str
- if outp then writech(scrdev, str)
- return 0
-
- EndString: PROCEDURE EXPOSE outp output usereq pgopen scrdev pscr
- parse arg str
- if pgopen then Postmsg()
- /* If you turned off stdout, no error messages will be shown! */
- if usereq then
- rtezrequest(str,'E_xit','Links Message:','rt_pubscrname = '||PSCR)
- else do
- Tell(str || '0A'x)
- end
- if outp & ~usereq & (scrdev ~= stdout) then do
- Tell("Press <return> to exit.")
- readln(scrdev)
- close(scrdev)
- end
- close(output)
- EXIT
-
- IOERR:
- bline = SIGL
- say "I/O error #"||RC||" detected in line "||bline||":"
- say sourceline(bline)
- if pgopen then Postmsg()
- EXIT
-